{-# LANGUAGE CPP #-}
{-# LANGUAGE ForeignFunctionInterface #-}
{-# LANGUAGE JavaScriptFFI #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

{-
  Copyright 2020 The CodeWorld Authors. All Rights Reserved.

  Licensed under the Apache License, Version 2.0 (the "License");
  you may not use this file except in compliance with the License.
  You may obtain a copy of the License at

      http://www.apache.org/licenses/LICENSE-2.0

  Unless required by applicable law or agreed to in writing, software
  distributed under the License is distributed on an "AS IS" BASIS,
  WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
  See the License for the specific language governing permissions and
  limitations under the License.
-}

-- Parse the Blockly structure into a Expr

module Blocks.Parser
  ( Error (..),
    SaveErr (..),
    Expr (..),
    Type (..),
    blockCodeMap,
    getGenerationBlocks,
  )
where

import Blockly.Block
import Control.Applicative
import Control.Monad
import Control.Monad.Fail
import Data.JSString.Text
import Data.List (intercalate)
import qualified Data.Map as M
import Data.Maybe (fromJust)
import Data.Monoid ((<>))
import qualified Data.Text as T
import Debug.Trace
import GHCJS.Foreign
import GHCJS.Foreign.Callback
import GHCJS.Marshal
import GHCJS.Types
import qualified JavaScript.Array as JA
import Unsafe.Coerce
import qualified Prelude as P
import Prelude hiding ((<>), show)

-- Helpers for converting Text
pack = textToJSString

unpack = textFromJSString

show :: Show a => a -> T.Text
show = T.pack . P.show

data Error = Error T.Text Block -- errorMsg, block

-- always return a, only return first error, monadic interface
data SaveErr a = SE a (Maybe Error)

instance Functor SaveErr where
  fmap = liftM

instance Applicative SaveErr where
  pure = return
  (<*>) = ap

instance Monad SaveErr where
  return a = SE a Nothing
  (SE code Nothing) >>= f = f code
  (SE code err@(Just e)) >>= f = do
    case f code of
      (SE code_ Nothing) -> SE code_ err
      (SE code_ a) -> SE code_ err

instance MonadFail SaveErr where
  fail = error

push a = SE a Nothing

errc :: T.Text -> Block -> SaveErr Expr
errc msg block = SE Comment $ Just $ Error msg block

errs :: T.Text -> Block -> SaveErr T.Text
errs msg block = SE "" $ Just $ Error msg block

errDisc = errc "There's a block missing" -- error when searching for a connected block

errInfix = errc "This block needs two blocks to be connected" -- error in missing inputs in infix block

errMsgsFunc = "This block requires a function block to be connected" -- error for simulationOf,

errFunc = errc errMsgsFunc

errFunc_ = errs errMsgsFunc

type ParserFunction = Block -> SaveErr Expr

-- A simple AST that will be used to store the structure of the code
-- We aren't too worried about types at this point (for now)

data Expr
  = LiteralS T.Text
  | LiteralN Float
  | LocalVar T.Text
  | CallFunc T.Text [Expr] -- name(arg1, arg2,...)
  | CallConstr T.Text [Expr] -- RGBA a b c
  | CallFuncInfix T.Text Expr Expr -- left <> right
  | FuncDef T.Text [T.Text] Expr -- let name x y z = expr
  | If Expr Expr Expr -- if expr then expr else expr
  | Case Expr [(T.Text, [T.Text], Expr)] -- case expr of consName vars expr
  | Tuple [Expr]
  | UserType Type
  | TypeName T.Text
  | ListCreate [Expr] -- [1,2,3]
  | ListSpec Expr Expr -- [left..right]
  | ListSpecStep Expr Expr Expr -- [left,mid..right]
  | ListComp Expr [(T.Text, Expr)] [Expr] -- [action | var <- expr, var <- expr, guards]
  | Comment
  deriving (Show)

data Type
  = Type T.Text
  | ListType Type -- [type] -- unfortunately its separate for the special syntax
  | Product T.Text [Type]
  | Sum T.Text [Type]
  deriving (Show)

-- data Product = Product T.Text [Type] -- Constructor tp1*tp2*tp3

-- standard function block, automatically handles machinery for functions
-- assumes inputs are in correct order
sFuncBlock :: ParserFunction
sFuncBlock block = do
  let argNames = getValueInputNames block
  let funcName = getFunctionName block
  args <- mapM (\arg -> valueToExpr block arg) argNames
  return $ CallFunc funcName args

sInfixBlock :: ParserFunction
sInfixBlock block = do
  let argNames = getValueInputNames block
  let funcName = getFunctionName block
  if length argNames /= 2
    then errInfix block
    else do
      args@(left : right : xs) <- mapM (\arg -> valueToExpr block arg) argNames
      return (CallFuncInfix funcName left right)

-- PROGRAMS --------------------------------------
blockDrawingOf :: ParserFunction
blockDrawingOf block = do
  expr <- valueToExpr block "VALUE"
  return $ FuncDef "program" [] $ CallFunc "drawingOf" [expr]

-- NUMBERS -------------------------------------------------------

blockNumber :: ParserFunction
blockNumber block = do
  let arg = getFieldValue block "NUMBER"
  return $ LiteralN (read $ T.unpack arg)

blockNumberPerc :: ParserFunction
blockNumberPerc block = do
  let arg = getFieldValue block "NUMBER"
  let numb = (read (T.unpack arg)) * 0.01
  return $ LiteralN numb

-- PICTURES ----------------------------------------------
blockCombine :: ParserFunction
blockCombine block = do
  let c = getItemCount block
  vals <- mapM (\t -> valueToExpr block t) ["PIC" <> show i | i <- [0 .. c -1]]
  return $ case vals of
    [] -> CallFuncInfix "&" (CallFunc "blank" []) (CallFunc "blank" [])
    [x] -> CallFuncInfix "&" x (CallFunc "blank" [])
    _ -> foldr1 (CallFuncInfix "&") vals

-- TEXT --------------------------------------------------

-- Escapes a string

escape :: T.Text -> T.Text
escape xs = T.pack $ escape' (T.unpack xs)

escape' :: String -> String
escape' = P.show

blockString :: ParserFunction
blockString block = do
  let txt = getFieldValue block "TEXT"
  return $ LiteralS $ escape txt

blockConcat :: ParserFunction
blockConcat block = do
  let c = getItemCount block
  vals <- mapM (\t -> valueToExpr block t) ["STR" <> show i | i <- [0 .. c -1]]
  return $ case vals of
    [] -> CallFuncInfix "<>" (LiteralS "") (LiteralS "")
    [x] -> CallFuncInfix "<>" x (LiteralS "")
    _ -> foldr1 (CallFuncInfix "<>") vals

-- LOGIC ------------------------------------------

blockIf :: ParserFunction
blockIf block = do
  ifexpr <- valueToExpr block "IF"
  thenexpr <- valueToExpr block "THEN"
  elseexpr <- valueToExpr block "ELSE"
  return $ If ifexpr thenexpr elseexpr

#ifdef ghcjs_HOST_OS

-- Let function block with parameters
foreign import javascript unsafe "$1.arguments_"
  js_funcargs :: Block -> JA.JSArray

#else

js_funcargs :: Block -> JA.JSArray
js_funcargs = error "GHCJS required"

#endif

blockLetFunc :: ParserFunction
blockLetFunc block = do
  let name = getFieldValue block "NAME"
  let vars =
        map unpack $ map (\n -> unsafeCoerce n :: JSString)
          $ JA.toList
          $ js_funcargs block
  expr <- valueToExpr block "RETURN"
  return $ FuncDef name vars expr

blockLetCall :: ParserFunction
blockLetCall block = do
  let name = getFieldValue block "NAME"
  let args =
        map unpack $ map (\n -> unsafeCoerce n :: JSString)
          $ JA.toList
          $ js_funcargs block
  vals <- mapM (\t -> valueToExpr block t) ["ARG" <> show i | i <- [0 .. length args - 1]]
  return $ CallFunc name vals

blockLocalVar :: ParserFunction
blockLocalVar block = do
  let name = getFieldValue block "NAME"
  return $ CallFunc name []

-- ANIMATION
blockAnim :: ParserFunction
blockAnim block = do
  draw <- aux "FUNC"
  return $ FuncDef "program" [] $
    CallFunc
      "animationOf"
      [CallFunc draw []]
  where
    aux name = case getInputBlock block name of
      Just inpBlock -> return $ getFunctionName inpBlock
      Nothing -> errFunc_ block

blockActivity :: ParserFunction
blockActivity block = do
  initial <- aux "INITIAL"
  event <- aux "EVENT"
  draw <- aux "DRAW"
  return $ FuncDef "program" [] $
    CallFunc
      "activityOf"
      [CallFunc initial [], CallFunc event [], CallFunc draw []]
  where
    aux name = case getInputBlock block name of
      Just inpBlock -> return $ getFunctionName inpBlock
      Nothing -> errFunc_ block

blockSimulation :: ParserFunction
blockSimulation block = do
  initial <- aux "INITIAL"
  step <- aux "STEP"
  draw <- aux "DRAW"
  return $ FuncDef "program" [] $
    CallFunc
      "simulationOf"
      [CallFunc initial [], CallFunc step [], CallFunc draw []]
  where
    aux name = case getInputBlock block name of
      Just inpBlock -> return $ getFunctionName inpBlock
      Nothing -> errFunc_ block

blockInteraction :: ParserFunction
blockInteraction block = do
  initial <- aux "INITIAL"
  step <- aux "STEP"
  event <- aux "EVENT"
  draw <- aux "DRAW"
  return $ FuncDef "program" [] $
    CallFunc
      "interactionOf"
      [ CallFunc initial [],
        CallFunc step [],
        CallFunc event [],
        CallFunc draw []
      ]
  where
    aux name = case getInputBlock block name of
      Just inpBlock -> return $ getFunctionName inpBlock
      Nothing -> errFunc_ block

-- COMMENT
blockComment :: ParserFunction
blockComment block = return $ Comment

-- Tuples
blockCreatePair :: ParserFunction
blockCreatePair block = do
  first <- valueToExpr block "FIRST"
  second <- valueToExpr block "SECOND"
  return $ Tuple [first, second]

-- LISTS

blockCreateList :: ParserFunction
blockCreateList block = do
  let c = getItemCount block
  vals <- mapM (\t -> valueToExpr block t) ["ADD" <> show i | i <- [0 .. c -1]]
  return $ ListCreate vals

blockNumGen :: ParserFunction
blockNumGen block = do
  left <- valueToExpr block "LEFT"
  right <- valueToExpr block "RIGHT"
  return $ ListSpec left right

blockNumGenStep :: ParserFunction
blockNumGenStep block = do
  left <- valueToExpr block "LEFT"
  next <- valueToExpr block "NEXT"
  right <- valueToExpr block "RIGHT"
  return $ ListSpecStep left next right

-- LIST COMPREHENSION
#ifdef ghcjs_HOST_OS

foreign import javascript unsafe "$1.varCount_"
  js_blockVarCount :: Block -> Int

foreign import javascript unsafe "$1.guardCount_"
  js_blockGuardCount :: Block -> Int

foreign import javascript unsafe "$1.vars_"
  js_blockVars :: Block -> JA.JSArray

#else

js_blockVarCount :: Block -> Int
js_blockVarCount = error "GHCJS required"

js_blockGuardCount :: Block -> Int
js_blockGuardCount = error "GHCJS required"

js_blockVars :: Block -> JA.JSArray
js_blockVars = error "GHCJS required"

#endif

-- ListComp Expr [(T.Text,Expr)] [Expr] -- [action | var <- expr, var <- expr, guards]
blockListComp :: ParserFunction
blockListComp block = do
  let varCount = js_blockVarCount block
  let guardCount = js_blockGuardCount block
  let vars =
        map unpack $ map (\n -> unsafeCoerce n :: JSString)
          $ JA.toList
          $ js_blockVars block

  varCodes <- mapM (\t -> valueToExpr block t) ["VAR" <> show i | i <- [0 .. varCount -1]]
  guards <- mapM (\t -> valueToExpr block t) ["GUARD" <> show i | i <- [0 .. guardCount -1]]
  doCode <- valueToExpr block "DO"

  return $ ListComp doCode (zip vars varCodes) guards

-- TYPES

#ifdef ghcjs_HOST_OS

foreign import javascript unsafe "$1.itemCount_"
  js_itemCount :: Block -> Int

#else

js_itemCount :: Block -> Int
js_itemCount = error "GHCJS required"

#endif

blockUserType :: ParserFunction
blockUserType block = do
  let name = getFieldValue block "NAME"
  return $ UserType $ Type name

blockListType :: ParserFunction
blockListType block = do
  tp <- valueToExpr block "TP"
  return $ UserType $ ListType $ toType tp
  where
    toType (UserType tp) = tp
    toType _ = Type ""

blockConstructor :: ParserFunction
blockConstructor block = do
  let name :: T.Text = getFieldValue block "NAME"
  let itemCount = js_itemCount block
  tps :: [Expr] <- mapM (\n -> valueToExpr block n) ["TP" <> show i | i <- [0 .. itemCount -1]]
  let out :: Expr = CallConstr name tps
  return $ out

blockProduct :: ParserFunction
blockProduct block = do
  let constructor = getFieldValue block "CONSTRUCTOR"
  let itemCount = js_itemCount block
  tps :: [Expr] <- mapM (\n -> valueToExpr block n) ["TP" <> show i | i <- [0 .. itemCount -1]]
  return $ UserType $ Product constructor $ map toType tps
  where
    toType (UserType tp) = tp
    toType _ = Type ""

blockSum :: ParserFunction
blockSum block = do
  let typeName = getFieldValue block "NAME"
  let itemCount = js_itemCount block
  tps <- mapM (\n -> valueToExpr block n) ["PROD" <> show i | i <- [0 .. itemCount -1]]
  return $ UserType $ Sum typeName (map toType tps)
  where
    toType (UserType tp) = tp
    toType _ = Type ""

-- CASE

#ifdef ghcjs_HOST_OS

foreign import javascript unsafe "$1.getInputVars($2)"
  js_getCaseInputVars :: Block -> Int -> JA.JSArray

foreign import javascript unsafe "$1.getInputConstructor($2)"
  js_getCaseInputConstructor :: Block -> Int -> JSString

#else

js_getCaseInputVars :: Block -> Int -> JA.JSArray
js_getCaseInputVars = error "GHCJS required"

js_getCaseInputConstructor :: Block -> Int -> JSString
js_getCaseInputConstructor = error "GHCJS required"

#endif

blockCase :: ParserFunction
blockCase block = do
  let name = getFieldValue block "NAME"
  let itemCount = js_itemCount block
  inp :: Expr <- valueToExpr block "INPUT"
  outs <- mapM (\n -> valueToExpr block n) ["CS" <> show i | i <- [0 .. itemCount -1]]
  let vars_ :: [[T.Text]] = map vars [0 .. itemCount -1]
  let cons_ :: [T.Text] = map con [0 .. itemCount -1]
  return $ Case inp (zip3 cons_ vars_ outs :: [(T.Text, [T.Text], Expr)])
  where
    vars i =
      map unpack $ map (\n -> unsafeCoerce n :: JSString)
        $ JA.toList
        $ js_getCaseInputVars block i
    con i = unpack $ js_getCaseInputConstructor block i

getGenerationBlocks :: [T.Text]
getGenerationBlocks = M.keys blockCodeMap

blockCodeMap = M.fromList $ concat [regularBlocks, specialBlocks, infixBlocks]

regularBlockNames =
  [ -- PROGRAMS
    "cwBlank",
    "cwCoordinatePlane",
    "cwCodeWorldLogo",
    "cwLettering",
    "cwCircle",
    "cwThickCircle",
    "cwSolidCircle",
    "cwRectangle",
    "cwThickRectangle",
    "cwSolidRectangle",
    "cwArc",
    "cwSector",
    "cwThickArc",
    -- TRANSFORMATIONS
    "lists_pictures",
    "cwColored",
    "cwTranslate",
    "cwRotate",
    "cwScale",
    -- NUMBERS
    "numMax",
    "numMin",
    "numOpposite",
    "numAbs",
    "numRound",
    "numReciprocal",
    "numQuot",
    "numRem",
    "numPi",
    "numSqrt",
    "numGCD",
    "numLCM",
    "numSin",
    "numCos",
    -- TEXT
    "txtPrinted",
    "txtLowercase",
    "txtUppercase",
    "txtCapitalized",
    -- COLORS
    "cwBlue",
    "cwRed",
    "cwGreen",
    "cwBrown",
    "cwOrange",
    "cwBlack",
    "cwWhite",
    "cwCyan",
    "cwMagenta",
    "cwYellow",
    "cwAquamarine",
    "cwAzure",
    "cwViolet",
    "cwChartreuse",
    "cwRose",
    "cwPink",
    "cwPurple",
    "cwGray",
    "cwMixed",
    "cwLight",
    "cwDark",
    "cwBright",
    "cwDull",
    "cwTranslucent",
    "cwRGBA",
    "cwRGB",
    "cwHSL",
    -- LOGIC
    "conNot",
    "conTrue",
    "conFalse",
    "conEven",
    "conOdd",
    "conStartWith",
    "conEndWith",
    -- Tuples
    "pair_first_typed",
    "pair_second_typed",
    -- Lists
    "lists_repeating",
    "lists_shuffled",
    "lists_sorted",
    "lists_reversed",
    "lists_first",
    "lists_rest",
    "lists_length",
    -- FUNCTIONS
    "lists_polyline",
    "lists_thickPolyline",
    "lists_polygon",
    "lists_solidPolygon",
    "lists_thickPolygon",
    "lists_curve",
    "lists_thickcurve",
    "lists_closedCurve",
    "lists_solidClosedCurve",
    "lists_thickClosedCurve"
    -- TYPES
  ]

regularBlocks :: [(T.Text, ParserFunction)]
regularBlocks = zip regularBlockNames (repeat sFuncBlock)

infixBlocks :: [(T.Text, ParserFunction)]
infixBlocks =
  [ ("numAdd", sInfixBlock),
    ("numSub", sInfixBlock),
    ("numMult", sInfixBlock),
    ("numDiv", sInfixBlock),
    ("numExp", sInfixBlock),
    ("conAnd", sInfixBlock),
    ("conOr", sInfixBlock),
    ("conEq", sInfixBlock),
    ("conNeq", sInfixBlock),
    ("conGreater", sInfixBlock),
    ("conGeq", sInfixBlock),
    ("conLess", sInfixBlock),
    ("conLeq", sInfixBlock),
    ("lists_cons", sInfixBlock),
    ("lists_at", sInfixBlock),
    ("lists_append", sInfixBlock)
  ]

specialBlocks :: [(T.Text, ParserFunction)]
specialBlocks =
  [ -- PROGRAMS
    ("cwDrawingOf", blockDrawingOf),
    ("cwAnimationOf", blockAnim),
    ("cwSimulationOf", blockSimulation),
    ("cwInteractionOf", blockInteraction),
    ("cwActivityOf", blockActivity),
    -- PICTURES
    ("cwCombine", blockCombine),
    -- NUMBERS
    ("numNumber", blockNumber),
    ("numNumberPerc", blockNumberPerc),
    -- TEXT
    ("text_typed", blockString),
    ("txtConcat", blockConcat),
    ("conIf", blockIf),
    ("pair_create_typed", blockCreatePair),
    ("lists_create_with_typed", blockCreateList),
    ("lists_cons", sInfixBlock),
    ("lists_numgen", blockNumGen),
    ("lists_numgenstep", blockNumGenStep),
    ("lists_comprehension", blockListComp),
    ("procedures_letFunc", blockLetFunc),
    ("procedures_callreturn", blockLetCall),
    ("vars_local", blockLocalVar),
    ("comment", blockComment),
    -- TYPES
    ("type_user", blockUserType),
    ("type_list", blockListType),
    ("expr_constructor", blockConstructor),
    ("expr_case", blockCase),
    ("type_product", blockProduct),
    ("type_sum", blockSum)
  ]

-- Assigns CodeGen functions defined here to the Blockly Javascript Code
-- generator

valueToExpr :: Block -> T.Text -> SaveErr Expr
valueToExpr block name = do
  case helper of
    Just (func, inputBlock) -> do
      code <- func inputBlock
      push $ code
    Nothing -> errDisc block
  where
    helper = do
      inputBlock <- getInputBlock block name
      let blockType = getBlockType inputBlock
      func <- M.lookup blockType blockCodeMap
      return (func, inputBlock)
